home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / contsens / unification.c < prev    next >
C/C++ Source or Header  |  1991-01-31  |  27KB  |  998 lines
  1.  
  2. /*   Copyright (C) 1990 Riet Oolman
  3.  
  4. This file is part of GLASS.
  5.  
  6. GLASS is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GLASS is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GLASS; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* file: unification.c
  21.    author: H. Oolman
  22.    last changed: 13-7-'90
  23.    purpose: unification of types for type-checking of GLASS
  24.    modifications:
  25.    updated for new version of Glass
  26.    p2c translated, tmc access procs
  27. */
  28.  
  29. #include "handleds.h"
  30. #include "check.ds.h"
  31. #include "check.var.h"
  32. #include "check.afuncs.h"
  33. #include "errorenv.h"
  34. #include "unification.h"
  35.  
  36. /* unification procedures for types. The types can have < relations */
  37.  
  38. Void becomes(t1, t2)
  39. typcrec *t1, *t2;
  40. {
  41.   /* t1 (tag UNKNOWN or SOME) should be changed to t2. This is done by
  42.      indirection. Therefore care must be taken to let all occurrences of t1 with
  43.      the same number have the same record. On inspecting
  44.      a type, these INDIRs should always be skipped */
  45.   t1->kind = kindINDIR;
  46.   t1->INDIR.tcind = t2;
  47. }
  48.  
  49.  
  50. boolean occurs(n, t)
  51. long n;
  52. typcrec *t;
  53. {
  54.   /* see if typename n does not occur as a real subpart of type t (this is not
  55.      allowed) */
  56.  
  57.   while (t->kind == kindINDIR) t = t->INDIR.tcind;
  58.   switch (t->kind) {
  59.  
  60.   case kindUNKNOWN:
  61.     return (t->UNKNOWN.unknm == n);
  62.     break;
  63.  
  64.   case kindSOME:
  65.     if (t->SOME.somnr == n)
  66.       return true;
  67.     else
  68.       return occurs(n, t->SOME.tcpart);
  69.     break;
  70.  
  71.   case kindSINGLEARROW:
  72.     return occurs(n, t->SINGLEARROW.tcarg) | occurs(n, t->SINGLEARROW.tcres);
  73.     break;
  74.  
  75.   case kindCT:
  76.     return occurs(n, t->CT.tcfirst) | occurs(n, t->CT.tcrest);
  77.     break;
  78.  
  79.   case kindSYSTY:
  80.     return occurs(n, t->SYSTY.syscomp);
  81.     break;
  82.  
  83.   case kindINT:
  84.   case kindFLOAT:
  85.   case kindBOOL:
  86.   case kindSTRING:
  87.   case kindEMPTYT:
  88.   case kindBASETY:
  89.   case kindAPS:
  90.   case kindLOC:
  91.     return false;
  92.     break;
  93.  
  94.   case kindALL:
  95.     return occurs(n, t->ALL.tcall);
  96.     break;
  97.   }
  98. }  /* occurs */
  99.  
  100.  
  101. boolean restrictable(mustendemp, mustconn, ty, vl)
  102. boolean mustendemp, mustconn;
  103. typcrec *ty;
  104. val vl;
  105. {
  106.   /* if mustendemp then ty must be a (tuple) type ending in the empty
  107.      type; if mustconn ty may only be a type fit for connections. Error
  108.      if conditions not fullfilled.
  109.      UNKNOWNs in ty are restricted (in their mustendemp and mustconn fields)
  110.      to the demands
  111.      The result tells if restricting could be done without errors
  112.      vl: the expression that causes restrictable to be called */
  113.   boolean rb;
  114.  
  115.   rb = true;
  116.   if (!(mustendemp || mustconn)) return rb;
  117.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  118.   switch (ty->kind) {
  119.  
  120.   case kindSYSTY:
  121.   case kindINT:
  122.   case kindFLOAT:
  123.   case kindBOOL:
  124.   case kindSTRING:
  125.   case kindAPS:
  126.   case kindSINGLEARROW:
  127.     if (mustendemp) {
  128.       error(15L, ty, NULL, NULL, vl, false);
  129.       rb = false;
  130.     }
  131.     if (mustconn) {
  132.       rb = false;
  133.       error(16L, ty, NULL, NULL, vl, false);
  134.     }
  135.     break;
  136.  
  137.   case kindEMPTYT:   /* always right */
  138.     break;
  139.  
  140.   case kindLOC:
  141.     if (mustendemp) {
  142.       rb = false;
  143.       error(15L, ty, NULL, NULL, vl, false);
  144.     }
  145.     break;
  146.  
  147.   case kindCT:
  148.     rb = restrictable(false, mustconn, ty->CT.tcfirst, vl) |
  149.      restrictable(false, mustconn, ty->CT.tcrest, vl);
  150.     break;
  151.  
  152.   /* assumption: CT only constructed with mustendemp satisfied */
  153.   case kindALL:
  154.     rb = false;
  155.     error(10L, NULL, NULL, Buildsymbol("restrictable", 12L), NULL, false);
  156.     break;
  157.  
  158.   case kindUNKNOWN:
  159.     ty->UNKNOWN.mustendemp = (ty->UNKNOWN.mustendemp || mustendemp);
  160.     ty->UNKNOWN.mustconn = (ty->UNKNOWN.mustconn || mustconn);
  161.     break;
  162.  
  163.   case kindSOME:
  164.     rb = restrictable(false, mustconn, ty->SOME.tcpart, vl);
  165.     break;
  166.  
  167.   case kindBASETY:
  168.     if (mustendemp) {
  169.       rb = false;
  170.       error(15L, ty, NULL, NULL, vl, false);
  171.     }
  172.     break;
  173.   }
  174.   return rb;
  175. }  /* restrictable */
  176.  
  177.  
  178. Local Void largerdir(dg1, dg2, direrfnd, vl)
  179. dirgraphrec *dg1, *dg2;
  180. boolean *direrfnd;
  181. val vl;
  182. {
  183.   /* dg1 should be larger than dg2. dgi are directions of a system's type.
  184.      ? < none, ! < none
  185.      direrfnd<-> direction error already found and notified
  186.      vl: for which an error can be found */
  187.   switch (dg1->kind) {
  188.  
  189.   case kindCd:
  190.     switch (dg2->kind) {
  191.  
  192.     case kindCd:
  193.       largerdir(dg1->Cd.dgfirst, dg2->Cd.dgfirst, direrfnd, vl);
  194.       largerdir(dg1->Cd.dgrest, dg2->Cd.dgrest, direrfnd, vl);
  195.       break;
  196.  
  197.     case kindSd:
  198.       largerdir(dg1->Cd.dgfirst, dg2->Sd.dgpart, direrfnd, vl);
  199.       largerdir(dg1->Cd.dgrest, dg2, direrfnd, vl);
  200.       break;
  201.  
  202.     case kindOd:
  203.       largerdir(dg1->Cd.dgfirst, dg2, direrfnd, vl);
  204.       largerdir(dg1->Cd.dgrest, dg2, direrfnd, vl);
  205.       break;
  206.     }
  207.     break;
  208.  
  209.   case kindSd:
  210.     switch (dg2->kind) {
  211.  
  212.     case kindCd:
  213.       largerdir(dg1->Sd.dgpart, dg2->Cd.dgfirst, direrfnd, vl);
  214.       largerdir(dg1, dg2->Cd.dgrest, direrfnd, vl);
  215.       break;
  216.  
  217.     case kindSd:
  218.       largerdir(dg1->Sd.dgpart, dg2->Sd.dgpart, direrfnd, vl);
  219.       largerdir(dg1->Sd.dglast, dg2->Sd.dglast, direrfnd, vl);
  220.       break;
  221.  
  222.     case kindOd:
  223.       largerdir(dg1->Sd.dgpart, dg2, direrfnd, vl);
  224.       largerdir(dg1->Sd.dglast, dg2, direrfnd, vl);
  225.       break;
  226.     }
  227.     break;
  228.  
  229.   case kindOd:
  230.     switch (dg2->kind) {
  231.  
  232.     case kindCd:
  233.       largerdir(dg1, dg2->Cd.dgfirst, direrfnd, vl);
  234.       largerdir(dg1, dg2->Cd.dgrest, direrfnd, vl);
  235.       break;
  236.  
  237.     case kindSd:
  238.       largerdir(dg1, dg2->Sd.dgpart, direrfnd, vl);
  239.       largerdir(dg1, dg2->Sd.dglast, direrfnd, vl);
  240.       break;
  241.  
  242.     case kindOd:
  243.       if (!*direrfnd && dg1->Od.basedir->kind != dg2->Od.basedir->kind &&
  244.       dg1->Od.basedir->kind != kindNON) {
  245.     error(14L, NULL, NULL, NULL, vl, false);
  246.     *direrfnd = true;
  247.       }
  248.       break;
  249.     }
  250.     break;
  251.   }
  252. }  /* largerdir */
  253.  
  254.  
  255. Void compat(t1, t2, vl)
  256. typcrec *t1, *t2;
  257. val vl;
  258. {
  259.   /* change unknown parts of t1 and t2 (as little as possible) (by becomes)
  260.      such that t2 after that can be enlarged to t1 (t2<t1)
  261.      vl: expression that causes the compat to be done */
  262.   typcrec *ht;
  263.   boolean direrfnd;
  264.  
  265.   /* !! bij invullen van namen moet < / > gebruikt */
  266.   while (t2->kind == kindINDIR) t2 = t2->INDIR.tcind;
  267.   while (t1->kind == kindINDIR) t1 = t1->INDIR.tcind;
  268.   if (t2->kind == kindUNKNOWN) {
  269.     if (t1->kind == kindUNKNOWN) 
  270.     { if (t2->UNKNOWN.unknm != t1->UNKNOWN.unknm) 
  271.       { if (restrictable(t2->UNKNOWN.mustendemp, t2->UNKNOWN.mustconn, t1, vl))
  272.       becomes(t2, t1);
  273.       }
  274.       return;
  275.     }
  276.     if (occurs(t2->UNKNOWN.unknm, t1))
  277.       error(11L, t1, NULL, NULL, NULL, false);
  278.     else {
  279.       if (restrictable(t2->UNKNOWN.mustendemp, t2->UNKNOWN.mustconn, t1, vl))
  280.     becomes(t2, t1);
  281.     }
  282.     return;
  283.   }
  284.   switch (t1->kind) {
  285.  
  286.   case kindUNKNOWN:
  287.     if (occurs(t1->UNKNOWN.unknm, t2))
  288.       error(11L, t2, NULL, NULL, NULL, false);
  289.     else {
  290.       if (restrictable(t1->UNKNOWN.mustendemp, t1->UNKNOWN.mustconn, t2, vl))
  291.     becomes(t1, t2);
  292.     }
  293.     break;
  294.  
  295.   case kindSINGLEARROW:
  296.     if (t2->kind == kindSINGLEARROW) {
  297.       compat(t2->SINGLEARROW.tcarg, t1->SINGLEARROW.tcarg, vl);
  298.       compat(t1->SINGLEARROW.tcres, t2->SINGLEARROW.tcres, vl);
  299.     } else
  300.       error(12L, t2, t1, NULL, vl, false);
  301.     break;
  302.  
  303.   case kindINT:
  304.     if (t2->kind != kindINT)
  305.       error(12L, t2, t1, NULL, vl, false);
  306.     break;
  307.  
  308.   case kindFLOAT:
  309.     if (t2->kind != kindFLOAT)
  310.       error(12L, t2, t1, NULL, vl, false);
  311.     break;
  312.  
  313.   case kindBOOL:
  314.     if (t2->kind != kindBOOL)
  315.       error(12L, t2, t1, NULL, vl, false);
  316.     break;
  317.  
  318.   case kindSTRING:
  319.     if (t2->kind != kindSTRING)
  320.       error(12L, t2, t1, NULL, vl, false);
  321.     break;
  322.  
  323.   case kindSYSTY:
  324.     if (t2->kind == kindSYSTY) {
  325.       direrfnd = false;
  326.       largerdir(t1->SYSTY.sysdirs, t2->SYSTY.sysdirs, &direrfnd, vl);
  327.       compat(t1->SYSTY.syscomp, t2->SYSTY.syscomp, vl);
  328.     } else
  329.       error(12L, t2, t1, NULL, vl, false);
  330.     break;
  331.  
  332.   case kindAPS:
  333.     /* if t2^.kind = kindSYSTY
  334.          then compat(BuildSYSTY(BuildOd(BuildNON),BuildBUNDLE(ht)),t2,vl)
  335.          else */
  336.     if (t2->kind != kindAPS)
  337.       error(12L, t2, t1, NULL, vl, false);
  338.     break;
  339.  
  340.   case kindCT:
  341.     if (t2->kind == kindCT) {
  342.       compat(t1->CT.tcfirst, t2->CT.tcfirst, vl);
  343.       compat(t1->CT.tcrest, t2->CT.tcrest, vl);
  344.     } else if (t2->kind == kindSOME) {
  345.       if (!occurs(t2->SOME.somnr, t1)) {
  346.     ht = BuildCT(t2->SOME.tcpart, BuildSOME(t2->SOME.tcpart, newname()));
  347.     becomes(t2, ht);
  348.     compat(t1, ht, vl);
  349.       } else
  350.     error(11L, t1, NULL, NULL, NULL, false);
  351.     } else
  352.       error(12L, t2, t1, NULL, vl, false);
  353.     break;
  354.  
  355.   case kindLOC:
  356.     if (t2->kind == kindLOC) {
  357.       if (!(Equalsymbol(t2->LOC.locname, t1->LOC.locname) &&
  358.         t1->LOC.inst == t2->LOC.inst))
  359.     error(12L, t2, t1, NULL, vl, false);
  360.     } else
  361.       error(12L, t2, t1, NULL, vl, false);
  362.     break;
  363.  
  364.   case kindBASETY:
  365.     if (t2->kind == kindBASETY) {
  366.       if (!(Equalsymbol(t2->BASETY.btname, t1->BASETY.btname) &&
  367.         t1->BASETY.bnr == t2->BASETY.bnr))
  368.     error(12L, t2, t1, NULL, vl, false);
  369.     } else
  370.       error(12L, t2, t1, NULL, vl, false);
  371.     break;
  372.  
  373.   case kindSOME:
  374.     if (t2->kind == kindCT) {
  375.       if (!occurs(t1->SOME.somnr, t2)) {
  376.     ht = BuildCT(t1->SOME.tcpart, BuildSOME(t1->SOME.tcpart, newname()));
  377.     becomes(t1, ht);
  378.     compat(ht, t2, vl);
  379.       } else
  380.     error(11L, t2, NULL, NULL, NULL, false);
  381.     } else if (t2->kind == kindSOME) {
  382.       compat(t1->SOME.tcpart, t2->SOME.tcpart, vl);
  383.       if (t1->SOME.somnr != t2->SOME.somnr) {
  384.     if (!occurs(t1->SOME.somnr, t2)) {becomes(t1, t2);}
  385.     else error(11L, t1, NULL, NULL, NULL, false);
  386.       }
  387.     } else if (t2->kind == kindEMPTYT) {
  388.       if (!forfull)
  389.     becomes(t1, t2);
  390.     } else
  391.       error(12L, t2, t1, NULL, vl, false);
  392.     break;
  393.  
  394.   case kindEMPTYT:
  395.     if (!forfull && t2->kind == kindSOME)
  396.       becomes(t2, t1);
  397.     else if (t2->kind != kindEMPTYT)
  398.       error(12L, t2, t1, NULL, vl, false);
  399.     break;
  400.  
  401.   case kindALL:
  402.     /* ALL should not be treated here */
  403.     error(10L, NULL, NULL, Buildsymbol(
  404.     "compat                                                                                                                                                                                                                                                          ",
  405.     6L), NULL, false);
  406.     break;
  407.   }
  408. }  /* compat */
  409.  
  410.  
  411. Static dirgraphrec *uplodir(islower_, dg1, dg2, direrfnd, vl)
  412. boolean islower_;
  413. dirgraphrec *dg1, *dg2;
  414. boolean *direrfnd;
  415. val vl;
  416. {
  417.   /* delivers the largest lowerbound of dg1 and dg2 if islower is true,
  418.      delivers the smallest upperbound of dg1 and dg2 if islower is false
  419.      direrfnd: direction error already found and notified
  420.      vl: for which an error can be found */
  421.   dirgraphrec *Result;
  422.  
  423.   switch (dg1->kind) {
  424.  
  425.   case kindCd:
  426.     switch (dg2->kind) {
  427.  
  428.     case kindCd:
  429.       Result = BuildCd(uplodir(islower_, dg1->Cd.dgfirst,
  430.                    dg2->Cd.dgfirst, direrfnd, vl),
  431.                uplodir(islower_, dg1->Cd.dgrest,
  432.                    dg2->Cd.dgrest, direrfnd, vl));
  433.       break;
  434.  
  435.     case kindSd:
  436.       Result = BuildCd(uplodir(islower_, dg1->Cd.dgfirst,
  437.                    dg2->Sd.dgpart, direrfnd, vl),
  438.       uplodir(islower_, dg1->Cd.dgrest, dg2, direrfnd, vl));
  439.       break;
  440.  
  441.     case kindOd:
  442.       Result = BuildCd(uplodir(islower_, dg1->Cd.dgfirst, dg2, direrfnd,
  443.                    vl), uplodir(islower_, dg1->Cd.dgrest,
  444.                          dg2, direrfnd, vl));
  445.       break;
  446.     }
  447.     break;
  448.  
  449.   case kindSd:
  450.     switch (dg2->kind) {
  451.  
  452.     case kindCd:
  453.       Result = BuildCd(uplodir(islower_, dg1->Sd.dgpart,
  454.                    dg2->Cd.dgfirst, direrfnd, vl),
  455.       uplodir(islower_, dg1, dg2->Cd.dgrest, direrfnd, vl));
  456.       break;
  457.  
  458.     case kindSd:
  459.       Result = BuildSd(uplodir(islower_, dg1->Sd.dgpart,
  460.                    dg2->Sd.dgpart, direrfnd, vl),
  461.                uplodir(islower_, dg1->Sd.dglast,
  462.                    dg2->Sd.dglast, direrfnd, vl));
  463.       break;
  464.  
  465.     case kindOd:
  466.       Result = BuildSd(uplodir(islower_, dg1->Sd.dgpart, dg2, direrfnd,
  467.                    vl), uplodir(islower_, dg1->Sd.dglast,
  468.                          dg2, direrfnd, vl));
  469.       break;
  470.     }
  471.     break;
  472.  
  473.   case kindOd:
  474.     switch (dg2->kind) {
  475.  
  476.     case kindCd:
  477.       Result = BuildCd(uplodir(islower_, dg1, dg2->Cd.dgfirst, direrfnd,
  478.                    vl),
  479.       uplodir(islower_, dg1, dg2->Cd.dgrest, direrfnd, vl));
  480.       break;
  481.  
  482.     case kindSd:
  483.       Result = BuildSd(uplodir(islower_, dg1, dg2->Sd.dgpart, direrfnd,
  484.                    vl),
  485.       uplodir(islower_, dg1, dg2->Sd.dglast, direrfnd, vl));
  486.       break;
  487.  
  488.     case kindOd:
  489.       if (islower_) {
  490.     if (dg1->Od.basedir->kind == dg2->Od.basedir->kind ||
  491.         dg2->Od.basedir->kind == kindNON)
  492.       Result = dg1;
  493.     else {
  494.       if (dg1->Od.basedir->kind == kindNON)
  495.         Result = dg2;
  496.       else {
  497.         if (!*direrfnd)
  498.           error(13L, NULL, NULL, NULL, vl, false);
  499.         *direrfnd = true;
  500.         Result = BuildOd(BuildNON());
  501.       }
  502.     }
  503.       } else if (dg1->Od.basedir->kind == dg2->Od.basedir->kind)
  504.     Result = dg1;
  505.       else
  506.     Result = BuildOd(BuildNON());
  507.       break;
  508.     }
  509.     break;
  510.   }
  511.   return Result;
  512. }  /* uplodir */
  513.  
  514.  
  515. /* changes t1 and t2 (as little as needed) such that lower<ti
  516.    (largest lowerbound)
  517.    vl: the expression that causes this function to be called */
  518. Static typcrec *lower PP((typcrec *t1, typcrec *t2, val vl));
  519.  
  520.  
  521. typcrec *upper(t1, t2, vl)
  522. typcrec *t1, *t2;
  523. val vl;
  524. {
  525.   /* changes t1 and t2 (as little as needed) such that upper>ti
  526.      (smallest upperbound)
  527.      vl: the expression that causes this procedure to be called */
  528.   typcrec *ht;
  529.   dirgraphrec *di;
  530.   boolean direrfnd;
  531.  
  532.   /* !! invulling niet  gedetailleerd genoeg */
  533.   while (t2->kind == kindINDIR) t2 = t2->INDIR.tcind;
  534.   while (t1->kind == kindINDIR) t1 = t1->INDIR.tcind;
  535.   if (t2->kind == kindUNKNOWN) 
  536.   { if (t1->kind == kindUNKNOWN) 
  537.     { if (t2->UNKNOWN.unknm != t1->UNKNOWN.unknm) 
  538.       { if (restrictable(t2->UNKNOWN.mustendemp, t2->UNKNOWN.mustconn, t1, vl))
  539.       becomes(t2, t1);
  540.       }
  541.       return t2;
  542.     }
  543.     if (occurs(t2->UNKNOWN.unknm, t1))
  544.       {error(11L, t1, NULL, NULL, NULL, false);
  545.        return BuildUNKNOWN(newname(),false,false);}
  546.     else 
  547.     { if (restrictable(t2->UNKNOWN.mustendemp, t2->UNKNOWN.mustconn, t1, vl))
  548.     becomes(t2, t1);
  549.     }
  550.     return t2;
  551.   }
  552.   switch (t1->kind) {
  553.  
  554.   case kindUNKNOWN:
  555.     if (occurs(t1->UNKNOWN.unknm, t2))
  556.       {error(11L, t2, NULL, NULL, NULL, false);
  557.        return BuildUNKNOWN(newname(),false,false);}
  558.     else 
  559.     { if (restrictable(t1->UNKNOWN.mustendemp, t1->UNKNOWN.mustconn, t2, vl))
  560.     becomes(t1, t2);
  561.     }
  562.     break;
  563.  
  564.   case kindSINGLEARROW:
  565.     if (t2->kind == kindSINGLEARROW)
  566.       return BuildSINGLEARROW(lower(t2->SINGLEARROW.tcarg, t1->SINGLEARROW.tcarg, vl),
  567.                 upper(t1->SINGLEARROW.tcres, t2->SINGLEARROW.tcres, vl));
  568.     else
  569.       {error(12L, t2, t1, NULL, vl, false);
  570.        return BuildUNKNOWN(newname(),false,false);}
  571.     break;
  572.  
  573.   case kindINT:
  574.     if (t2->kind != kindINT)
  575.       {error(12L, t2, t1, NULL, vl, false);
  576.        return BuildUNKNOWN(newname(),false,false);}
  577.     break;
  578.  
  579.   case kindFLOAT:
  580.     if (t2->kind != kindFLOAT)
  581.       {error(12L, t2, t1, NULL, vl, false);
  582.        return BuildUNKNOWN(newname(),false,false);}
  583.     break;
  584.  
  585.   case kindBOOL:
  586.     if (t2->kind != kindBOOL)
  587.       {error(12L, t2, t1, NULL, vl, false);
  588.        return BuildUNKNOWN(newname(),false,false);}
  589.     break;
  590.  
  591.   case kindSTRING:
  592.     if (t2->kind != kindSTRING)
  593.       {error(12L, t2, t1, NULL, vl, false);
  594.        return BuildUNKNOWN(newname(),false,false);}
  595.     break;
  596.  
  597.   case kindSYSTY:
  598.     if (t2->kind == kindSYSTY) {
  599.       direrfnd = false;
  600.       di = uplodir(false, t1->SYSTY.sysdirs, t2->SYSTY.sysdirs, &direrfnd,
  601.            vl);
  602.       ht = upper(t1->SYSTY.syscomp, t2->SYSTY.syscomp, vl);
  603.       if (direrfnd)
  604.     ht = BuildUNKNOWN(newname(), false, true);
  605.       return BuildSYSTY(di, ht);
  606.     } else
  607.       {error(12L, t2, t1, NULL, vl, false);
  608.        return BuildUNKNOWN(newname(),false,false);}
  609.     /*
  610.     else
  611.     if t2^.kind=APS
  612.     then
  613.     begin
  614.       compat(BuildSYSTY(BuildOd(BuildNON),BuildBUNDLE(ht)), t1,vl);
  615.       upper:=t2
  616.     end
  617.     else if t2^.kind=BUNDLE
  618.     then
  619.     begin
  620.       compat(BuildSYSTY(BuildCd(BuildOd(BuildIN),BuildOd(BuildOUT))
  621.                         ,
  622.                         BuildBUNDLE(BuildCT(ht, t2^.typc4))
  623.                        )
  624.              , t1
  625.              , vl);
  626.       upper:=t2
  627.     end
  628.     else if t2^.kind = EMPTYT
  629.     then
  630.     begin
  631.       compat(BuildSYSTY(BuildCd(BuildOd(BuildIN),BuildOd(BuildOUT))
  632.                         , BuildBUNDLE(BuildCT(ht, t2))
  633.                        )
  634.              , t1
  635.              , vl);
  636.       upper:=BuildBUNDLE(t2)
  637.     end
  638.     */
  639.     break;
  640.  
  641.   case kindAPS:
  642.     /* if t2^.kind = kindSYSTY
  643.          then compat(BuildSYSTY(BuildOd(BuildNON),BuildBUNDLE(ht)),t2,vl)
  644.          else */
  645.     if (t2->kind != kindAPS)
  646.       {error(12L, t2, t1, NULL, vl, false);
  647.        return BuildUNKNOWN(newname(),false,false);}
  648.     break;
  649.  
  650.   case kindCT:
  651.     if (t2->kind == kindCT)
  652.       return BuildCT(upper(t1->CT.tcfirst, t2->CT.tcfirst, vl),
  653.                upper(t1->CT.tcrest, t2->CT.tcrest, vl));
  654.     else if (t2->kind == kindSOME) {
  655.       if (!occurs(t2->SOME.somnr, t1)) {
  656.     ht = BuildCT(t2->SOME.tcpart, BuildSOME(t2->SOME.tcpart, newname()));
  657.     becomes(t2, ht); 
  658.     return upper(t1, ht, vl);
  659.       } else
  660.     {error(11L, t1, NULL, NULL, NULL, false);
  661.          return BuildUNKNOWN(newname(),false,false);}
  662.     } else
  663.       {error(12L, t2, t1, NULL, vl, false);
  664.        return BuildUNKNOWN(newname(),false,false);}
  665.     break;
  666.  
  667.   case kindLOC:
  668.     if (t2->kind == kindLOC) {
  669.       if (!(Equalsymbol(t2->LOC.locname, t1->LOC.locname) &&
  670.         t1->LOC.inst == t2->LOC.inst))
  671.     {error(12L, t2, t1, NULL, vl, false);
  672.          return BuildUNKNOWN(newname(),false,false);}
  673.     } else
  674.       {error(12L, t2, t1, NULL, vl, false);
  675.        return BuildUNKNOWN(newname(),false,false);}
  676.     break;
  677.  
  678.   case kindBASETY:
  679.     if (t2->kind == kindBASETY) {
  680.       if (!(Equalsymbol(t1->BASETY.btname, t2->BASETY.btname) &&
  681.         t1->BASETY.bnr == t2->BASETY.bnr))
  682.     {error(12L, t2, t1, NULL, vl, false);
  683.          return BuildUNKNOWN(newname(),false,false);}
  684.     } else
  685.       {error(12L, t2, t1, NULL, vl, false);
  686.        return BuildUNKNOWN(newname(),false,false);}
  687.     break;
  688.  
  689.   case kindSOME:
  690.     if (t2->kind == kindCT) 
  691.     { if (!occurs(t1->SOME.somnr, t2)) 
  692.       { ht = BuildCT(t1->SOME.tcpart, BuildSOME(t1->SOME.tcpart, newname()));
  693.     becomes(t1, ht); 
  694.     return upper(ht, t2, vl);
  695.       } else
  696.     {error(11L, t2, NULL, NULL, NULL, false);
  697.          return BuildUNKNOWN(newname(),false,false);}
  698.     } else if (t2->kind == kindSOME) 
  699.       {ht = BuildSOME(upper(t1->SOME.tcpart, t2->SOME.tcpart, vl),
  700.              t2->SOME.somnr);
  701.       if (t1->SOME.somnr != t2->SOME.somnr) 
  702.       { if (!occurs(t1->SOME.somnr, t2)) 
  703.       {becomes(t1, t2);} /* !! moet dit wel? */
  704.     else
  705.     {error(11L, t2, NULL, NULL, NULL, false);
  706.          return BuildUNKNOWN(newname(),false,false);}
  707.       }
  708.       return ht;
  709.     } else if (t2->kind == kindEMPTYT) {
  710.       if (!forfull) becomes(t1, t2);
  711.     } else
  712.       {error(12L, t2, t1, NULL, vl, false);
  713.        return BuildUNKNOWN(newname(),false,false);}
  714.     break;
  715.  
  716.   case kindEMPTYT:
  717.     if (t2->kind == kindSOME) {
  718.       if (!forfull) becomes(t2, t1);
  719.     } else {
  720.       if (t2->kind != kindEMPTYT)
  721.     {error(12L, t2, t1, NULL, vl, false);
  722.        return BuildUNKNOWN(newname(),false,false);}
  723.     }
  724.     /*
  725.     else
  726.     if t2^.kind=LIST
  727.     then upper:=t2
  728.     else
  729.     if t2^.kind=BUNDLE
  730.     then upper:=BuildBUNDLE(upper(ht,t2^.typc4,vl))
  731.     else
  732.     if t2^.kind = SYSTY
  733.     then
  734.     begin
  735.       if forfull
  736.       then ht2:=BuildSOME(BuildUNKNOWN(newname),newname)
  737.       else ht2:=BuildEMPTYT;
  738.       compat(BuildSYSTY(BuildCd(BuildOd(BuildIN),BuildOd(BuildOUT))
  739.                         , BuildBUNDLE(BuildCT(ht, ht2))
  740.                        )
  741.              , t2
  742.              , vl);
  743.       upper:=BuildBUNDLE(t1)
  744.     end
  745.     */
  746.     break;
  747.  
  748.   case kindALL:
  749.     {error(10L, NULL, NULL, Buildsymbol( "upper", 5L), NULL, false);
  750.        return BuildUNKNOWN(newname(),false,false);}
  751.     break;
  752.     /* ALL should not be treated here */
  753.   }
  754.   return t1;
  755. }  /* upper */
  756.  
  757.  
  758. typcrec *uppercomps(ty, vl)
  759. typcrec *ty;
  760. val vl;
  761. {
  762.   /* ty must be composed of a number of the same parts; the result
  763.     is the smallest type larger than each part
  764.     vl: the expression that causes this to be called */
  765.   typcrec *un;
  766.   errorrec *erl;
  767.   typcrec *tp;
  768.  
  769.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  770.    if (ty->kind == kindUNKNOWN) 
  771.     { un = BuildUNKNOWN(newname(), false, ty->UNKNOWN.mustconn);
  772.       /* !! hier ook gevaar verkeerde invulling? */
  773.       becomes(ty, BuildSOME(un, newname()));
  774.       return un;
  775.     } else {
  776.       if (ty->kind == kindSOME) return (ty->SOME.tcpart);
  777.       else {
  778.     if (ty->kind == kindCT)
  779.     { erl=errorlist;
  780.       tp = upper(ty->CT.tcfirst, uppercomps(ty->CT.tcrest, vl),
  781.             vl);
  782.       if (errorlist==erl) return tp;
  783.       else 
  784.       { error(17L, NULL, NULL, NULL, vl, false);
  785.         return tp;
  786.       }
  787.     }
  788.     else {
  789.       if (ty->kind != kindEMPTYT)
  790.         error(17L, NULL, NULL, NULL, vl, false);
  791.       return (BuildUNKNOWN(newname(), false, false));
  792.     }
  793.       }
  794.     }
  795. }  /* uppercomps */
  796.  
  797.  
  798. Static typcrec *lower(t1, t2, vl)
  799. typcrec *t1, *t2;
  800. val vl;
  801. {
  802.   typcrec  *ht;
  803.   dirgraphrec *di;
  804.   boolean direrfnd;
  805.  
  806.   /* !! invulling niet gedetaillerd genoeg */
  807.   while (t2->kind == kindINDIR) t2 = t2->INDIR.tcind;
  808.   while (t1->kind == kindINDIR) t1 = t1->INDIR.tcind;
  809.   if (t2->kind == kindUNKNOWN) {
  810.     if (t1->kind == kindUNKNOWN) {
  811.       if (t2->UNKNOWN.unknm != t1->UNKNOWN.unknm) {
  812.     if (restrictable(t2->UNKNOWN.mustendemp, t2->UNKNOWN.mustconn, t1, vl))
  813.       becomes(t2, t1);
  814.       }
  815.       return t2;
  816.     }
  817.     if (occurs(t2->UNKNOWN.unknm, t1))
  818.       {error(11L, t1, NULL, NULL, NULL, false);
  819.        return BuildUNKNOWN(newname(),false,false);}
  820.     else {
  821.       if (restrictable(t2->UNKNOWN.mustendemp, t2->UNKNOWN.mustconn, t1, vl))
  822.     becomes(t2, t1);
  823.     }
  824.     return t2;
  825.   }
  826.   switch (t1->kind) {
  827.  
  828.   case kindUNKNOWN:
  829.     if (occurs(t1->UNKNOWN.unknm, t2))
  830.       {error(11L, t2, NULL, NULL, NULL, false);
  831.        return BuildUNKNOWN(newname(),false,false);}
  832.     else {
  833.       if (restrictable(t1->UNKNOWN.mustendemp, t1->UNKNOWN.mustconn, t2, vl))
  834.     becomes(t1, t2);
  835.     }
  836.     break;
  837.  
  838.   case kindSINGLEARROW:
  839.     if (t2->kind == kindSINGLEARROW)
  840.       return BuildSINGLEARROW(upper(t2->SINGLEARROW.tcarg, t1->SINGLEARROW.tcarg, vl),
  841.                 lower(t1->SINGLEARROW.tcres, t2->SINGLEARROW.tcres, vl));
  842.     else
  843.       {error(12L, t2, t1, NULL, vl, false);
  844.        return BuildUNKNOWN(newname(),false,false);}
  845.     break;
  846.  
  847.   case kindINT:
  848.     if (t2->kind != kindINT)
  849.       {error(12L, t2, t1, NULL, vl, false);
  850.        return BuildUNKNOWN(newname(),false,false);}
  851.     break;
  852.  
  853.   case kindFLOAT:
  854.     if (t2->kind != kindFLOAT)
  855.       {error(12L, t2, t1, NULL, vl, false);
  856.        return BuildUNKNOWN(newname(),false,false);}
  857.     break;
  858.  
  859.   case kindBOOL:
  860.     if (t2->kind != kindBOOL)
  861.       {error(12L, t2, t1, NULL, vl, false);
  862.        return BuildUNKNOWN(newname(),false,false);}
  863.     break;
  864.  
  865.   case kindSTRING:
  866.     if (t2->kind != kindSTRING)
  867.       {error(12L, t2, t1, NULL, vl, false);
  868.        return BuildUNKNOWN(newname(),false,false);}
  869.     break;
  870.  
  871.   case kindSYSTY:
  872.     if (t2->kind == kindSYSTY) {
  873.       direrfnd = false;
  874.       di = uplodir(true, t1->SYSTY.sysdirs, t2->SYSTY.sysdirs, &direrfnd,
  875.            vl);
  876.       ht = lower(t1->SYSTY.syscomp, t2->SYSTY.syscomp, vl);
  877.       if (direrfnd)
  878.     ht = BuildUNKNOWN(newname(), false, true);
  879.       return BuildSYSTY(di, ht);
  880.     } else
  881.       {error(12L, t2, t1, NULL, vl, false);
  882.        return BuildUNKNOWN(newname(),false,false);}
  883.     /*
  884.     else
  885.     if t2^.kind=APS
  886.     then
  887.       compat(t1,BuildSYSTY(BuildOd(BuildNON),BuildBUNDLE(ht)),vl)
  888.     else if t2^.kind=BUNDLE
  889.     then
  890.       compat(t1,
  891.              BuildSYSTY(BuildCd(BuildOd(BuildIN),BuildOd(BuildOUT))
  892.                         ,
  893.                         BuildBUNDLE(BuildCT(ht, t2^.typc4))
  894.                        )
  895.             ,vl)
  896.             */
  897.     break;
  898.  
  899.   case kindAPS:
  900.     /* if t2^.kind = SYSTY
  901.          then begin
  902.                 compat(t2,BuildSYSTY(BuildOd(BuildNON),BuildBUNDLE(ht)),vl);
  903.                 lower:=t2
  904.               end
  905.          else */
  906.     if (t2->kind != kindAPS)
  907.       {error(12L, t2, t1, NULL, vl, false);
  908.        return BuildUNKNOWN(newname(),false,false);}
  909.     break;
  910.  
  911.   case kindCT:
  912.     if (t2->kind == kindCT)
  913.       return BuildCT(lower(t1->CT.tcfirst, t2->CT.tcfirst, vl),
  914.                lower(t1->CT.tcrest, t2->CT.tcrest, vl));
  915.     else if (t2->kind == kindSOME) {
  916.       if (!occurs(t2->SOME.somnr, t1)) {
  917.     ht = BuildCT(t2->SOME.tcpart, BuildSOME(t2->SOME.tcpart, newname()));
  918.     becomes(t2, ht);
  919.     return lower(t1, ht, vl);
  920.       } else
  921.     {error(11L, t1, NULL, NULL, NULL, false);
  922.        return BuildUNKNOWN(newname(),false,false);}
  923.     } else
  924.       {error(12L, t2, t1, NULL, vl, false);
  925.        return BuildUNKNOWN(newname(),false,false);}
  926.     break;
  927.  
  928.   case kindLOC:
  929.     if (t2->kind == kindLOC) {
  930.       if (!(Equalsymbol(t2->LOC.locname, t1->LOC.locname) &&
  931.         t1->LOC.inst == t2->LOC.inst))
  932.     {error(12L, t2, t1, NULL, vl, false);
  933.        return BuildUNKNOWN(newname(),false,false);}
  934.     } else
  935.       {error(12L, t2, t1, NULL, vl, false);
  936.        return BuildUNKNOWN(newname(),false,false);}
  937.     break;
  938.  
  939.   case kindBASETY:
  940.     if (t2->kind == kindBASETY) {
  941.       if (!(Equalsymbol(t1->BASETY.btname, t2->BASETY.btname) &&
  942.         t1->BASETY.bnr == t2->BASETY.bnr))
  943.     {error(12L, t2, t1, NULL, vl, false);
  944.        return BuildUNKNOWN(newname(),false,false);}
  945.     } else
  946.       {error(12L, t2, t1, NULL, vl, false);
  947.        return BuildUNKNOWN(newname(),false,false);}
  948.     break;
  949.  
  950.   case kindSOME:
  951.     if (t2->kind == kindCT) {
  952.       if (!occurs(t1->SOME.somnr, t2)) {
  953.     ht = BuildCT(t1->SOME.tcpart, BuildSOME(t1->SOME.tcpart, newname()));
  954.     becomes(t1, ht);
  955.     return lower(ht, t2, vl);
  956.       } else
  957.     {error(11L, t2, NULL, NULL, NULL, false);
  958.        return BuildUNKNOWN(newname(),false,false);}
  959.     } else if (t2->kind == kindSOME) {
  960.       ht = BuildSOME(lower(t1->SOME.tcpart, t2->SOME.tcpart, vl),
  961.              t2->SOME.somnr);
  962.       if (t1->SOME.somnr != t2->SOME.somnr) {
  963.     if (!occurs(t1->SOME.somnr, t2)) becomes(t1, t2); /* !! moet dit wel? */
  964.     else
  965.     {error(11L, t2, NULL, NULL, NULL, false);
  966.          return BuildUNKNOWN(newname(),false,false);}
  967.       return ht;
  968.       }
  969.     } else if (t2->kind == kindEMPTYT) {
  970.       if (!forfull)
  971.     becomes(t1, t2);
  972.     } else
  973.       {error(12L, t2, t1, NULL, vl, false);
  974.        return BuildUNKNOWN(newname(),false,false);}
  975.     break;
  976.  
  977.   case kindEMPTYT:
  978.     if (t2->kind == kindSOME) {
  979.       if (!forfull)
  980.     becomes(t2, t1);
  981.     } else {
  982.       if (t2->kind != kindEMPTYT)   /* and (t2^.kind<>LIST) */
  983.     {error(12L, t2, t1, NULL, vl, false);
  984.        return BuildUNKNOWN(newname(),false,false);}
  985.     }
  986.     /* else if t2^.kind=BUNDLE
  987.     then lower:=lower(t1,t2^.typc4,vl) */
  988.     break;
  989.  
  990.   case kindALL:
  991.     /* ALL needs not be treated here */
  992.     {error(10L, NULL, NULL, Buildsymbol( "lower", 5L), NULL, false);
  993.        return BuildUNKNOWN(newname(),false,false);}
  994.     break;
  995.   }
  996.   return t1;
  997. }  /* lower */
  998.